home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / txt2sp.com / TXT2SP.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-05-11  |  6.7 KB  |  221 lines
  1. {$R-,B-,S-,I+,N-}
  2.  
  3. program TextToSpeech (Input, Output);
  4.  
  5. { ***** Preliminary version ***** }
  6. { Author: Ron Schuster 76666,2322 }
  7.  
  8. type
  9.   CharSet = set of 'A'..'Z';
  10.  
  11. const
  12.   Vowels :           CharSet = ['A','E','I','O','U','Y'];
  13.   FrontVowels :      CharSet = ['E','I','Y'];
  14.   Consonants :       CharSet = ['B','C','D','F','G','H','J','K','L','M','N',
  15.                                 'P','Q','R','S','T','V','W','X','Z'];
  16.   VoicedConsonants : CharSet = ['B','D','G','J','L','M','N','R','V','W','Z'];
  17.   Sibilants :        CharSet = ['S','C','G','Z','X','J'];
  18.   UruleConsonants :  CharSet = ['T','S','R','D','L','Z','N','J'];
  19.   Set_CS          :  CharSet = ['C','S'];
  20.   Set_CST         :  CharSet = ['C','S','T'];
  21.   Set_AERU        :  CharSet = ['A','E','R','U'];
  22.   Set_ER          :  CharSet = ['E','R'];
  23.   Set_GK          :  CharSet = ['G','K'];
  24.   Set_EIORU       :  CharSet = ['E','I','O','R','U'];
  25.   Set_ERU         :  CharSet = ['E','R','U'];
  26.   MaxContextLen = 7;
  27.   MaxTransLen = 35;
  28.   MaxRuleCount = 600;
  29. var
  30.   Rule : array [1..MaxRuleCount] of record
  31.            LeftContext : string[MaxContextLen];
  32.            CenterContext : string[MaxContextLen];
  33.            RightContext : string[MaxContextLen];
  34.            Translation : string[MaxTransLen];
  35.          end;
  36.   RuleIndex : array [' '..'~'] of Integer;  { points to the first rule that
  37.                                               handles each character }
  38.   InStr, OutStr : string;
  39.   RuleCount, Code,
  40.   InPtr, RulePtr : Integer;
  41.  
  42. function Match (Context : Char; var InPtr : Integer; Direction : Integer) : Boolean;
  43. var
  44.   Temp : string[4];
  45. begin
  46.   case Context of
  47.     '!':  case InStr[InPtr] of                        { Non-alphabetic }
  48.             'A'..'Z','''': Match := False;
  49.             else Match := True;
  50.           end;
  51.     '#':  begin                                       { One or more vowels }
  52.             Match := False;
  53.             while InStr[InPtr] in Vowels do begin
  54.               InPtr := InPtr + Direction;
  55.               Match := True;
  56.             end;
  57.             InPtr := InPtr - Direction;
  58.           end;
  59.     '.':  Match := InStr[InPtr] in VoicedConsonants;  { A voiced consonant }
  60.     '%':  begin                                       { A suffix }
  61.             Match := True;
  62.             Temp := Copy(InStr, InPtr, 3);
  63.             if Length(Temp) = 3 then
  64.               if Temp <> 'ING' then
  65.                 if Temp <> 'ELY' then
  66.                   Dec(Temp[0]);
  67.             if Length(Temp) = 2 then
  68.               if Temp <> 'ES' then
  69.                 if Temp <> 'ER' then
  70.                   if Temp <> 'ED' then
  71.                     Dec(Temp[0]);
  72.             if Length(Temp) = 1 then
  73.               if Temp <> 'E' then
  74.                 Match := False;
  75.             Inc (InPtr, Pred(Length(Temp)));
  76.           end;
  77.     '&':  if InStr[InPtr] in Sibilants then            { Sibilants }
  78.             Match := True
  79.           else
  80.             Match := (InStr[InPtr] = 'H') and (InStr[InPtr-1] in Set_CS);
  81.     '@':  if InStr[InPtr] in UruleConsonants then     { A consonant influen- }
  82.             Match := True                             { cing the sound of    }
  83.           else                                        { following 'U'        }
  84.             Match := (InStr[InPtr] = 'H') and (InStr[InPtr-1] in Set_CST);
  85.     '^':  Match := InStr[InPtr] in Consonants;        { One consonant }
  86.     '+':  Match := InStr[InPtr] in FrontVowels;       { A front vowel }
  87.     ':':  begin                                       { Zero or more }
  88.             while InStr[InPtr] in Consonants do       { consonants }
  89.               InPtr := InPtr + Direction;
  90.             Match := True;
  91.             InPtr := InPtr - Direction;
  92.           end;
  93.     '$':  Match := InStr[InPtr] in Vowels;            { One vowel }
  94.     else  Match := InStr[InPtr] = Context;            { Literal }
  95.   end;
  96. end;
  97.  
  98. procedure TestRules;
  99. var
  100.   I,J : Integer;
  101.   OK : Boolean;
  102. begin
  103.   RulePtr := RuleIndex[InStr[InPtr]];
  104.   repeat
  105.     with Rule[RulePtr] do begin
  106.       OK := Copy(InStr,InPtr,Length(CenterContext)) = CenterContext;
  107.       if OK then begin
  108.         I := Length(LeftContext);
  109.         J := InPtr;
  110.         while OK and (I > 0) do begin
  111.           Dec(J);
  112.           OK := Match (LeftContext[I], J, -1);
  113.           Dec(I);
  114.         end;
  115.       end;
  116.       if OK then begin
  117.         I := 1;
  118.         J := InPtr + Length(CenterContext);
  119.         while OK and (I <= Length(RightContext)) do begin
  120.           OK := Match (RightContext[I], J, 1);
  121.           Inc(I);
  122.           Inc(J);
  123.         end;
  124.       end;
  125.     end; { with Rule[RulePtr] }
  126.     if not OK then
  127.       Inc(RulePtr);
  128.   until OK or (RulePtr > RuleCount);
  129. end;
  130.  
  131. procedure PrepareInputString;
  132. var
  133.   I : Integer;
  134. begin
  135.   for I := 1 to Length(InStr) do
  136.     InStr[I] := UpCase(InStr[I]);
  137.   InStr := ' '+ InStr + ' ';
  138. end;
  139.  
  140. {$R+}
  141. procedure ReadRules;
  142. var
  143.   RuleFile : text;
  144.   C : Char;
  145. begin
  146.   {$I-}
  147.   Assign (RuleFile, 'RULES.DAT');
  148.   Reset (RuleFile);
  149.   {$I+}
  150.   if IOresult <> 0 then begin
  151.     Writeln ('Could not open RULES.DAT');
  152.     Halt(1);
  153.   end;
  154.   RuleCount := 0;
  155.   for C := ' ' to '~' do
  156.     RuleIndex[C] := 0;
  157.   while not EOF(RuleFile) do begin
  158.     ReadLn (RuleFile, InStr);
  159.     RuleCount := RuleCount + 1;
  160.     with Rule[RuleCount] do begin
  161.       LeftContext := Copy (InStr, 1, Pos('[',InStr) - 1);
  162.       Delete (InStr, 1, Length(LeftContext) + 1);
  163.       if InStr[1] = ']' then
  164.         CenterContext := ']'
  165.       else
  166.         CenterContext := Copy (InStr, 1, Pos(']',InStr) - 1);
  167.       Delete (InStr, 1, Length(CenterContext) + 1);
  168.       RightContext := Copy (InStr, 1, Pos('=',InStr) - 1);
  169.       Delete (InStr, 1, Length(RightContext) + 1);
  170.       Translation := InStr;
  171.       C := CenterContext[1];
  172.       if RuleIndex[C] = 0 then
  173.         RuleIndex[C] := RuleCount;
  174.     end;
  175.   end;
  176.   Rule[RuleCount + 1].Translation := 'ERROR';
  177. end;
  178. {$R-}
  179.  
  180. procedure WriteOutput;
  181. begin
  182.   with Rule[RulePtr] do begin
  183.     OutStr := OutStr + Translation + ' ';
  184.     if Length(OutStr) > 80 then begin
  185.       Writeln (OutStr);
  186.       OutStr := '';
  187.     end;
  188.     Inc (InPtr, Length(CenterContext));
  189.   end;
  190. end;
  191.  
  192. procedure ProcessInputFile;
  193. begin
  194.   while not EOF(Input) do begin
  195.     OutStr := '';
  196.     Readln (Input, InStr);
  197.     PrepareInputString;
  198.     InPtr := 2;
  199.     while InPtr < Length(InStr) do begin
  200.       case InStr[InPtr] of
  201.         ' '..'~': if RuleIndex[InStr[InPtr]] = 0 then
  202.                     Inc(InPtr)
  203.                   else begin
  204.                     TestRules;
  205.                     WriteOutput;
  206.                   end;
  207.         else Inc(InPtr);
  208.       end;
  209.     end;
  210.     if Length(OutStr) > 0 then
  211.       Writeln (OutStr);
  212.   end;
  213.   Close(Output);
  214. end;
  215.  
  216. { main program }
  217. begin
  218.   ReadRules;
  219.   ProcessInputFile;
  220. end.
  221.